home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Mathematics / Notebooks / Cantor / CantorSet.ma < prev    next >
Encoding:
Text File  |  1992-08-07  |  10.6 KB  |  277 lines
  1. (*^
  2.  
  3. ::[paletteColors = 128; showRuler; currentKernel; 
  4.     fontset = title, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, L1, e8,  24, "Times"; ;
  5.     fontset = subtitle, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, L1, e6,  18, "Times"; ;
  6.     fontset = subsubtitle, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, italic, L1, e6,  14, "Times"; ;
  7.     fontset = section, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, grayBox, M22, bold, L1, a20,  18, "Times"; ;
  8.     fontset = subsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, blackBox, M19, bold, L1, a15,  14, "Times"; ;
  9.     fontset = subsubsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, whiteBox, M18, bold, L1, a12,  12, "Times"; ;
  10.     fontset = text, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1,  12;
  11.     fontset = smalltext, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1,  10, "Times"; ;
  12.     fontset = input, noPageBreakBelow, nowordwrap, preserveAspect, groupLikeInput, M42, N23, bold, L1,  12, "Courier"; ;
  13.     fontset = output, output, inactive, noPageBreakBelow, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L-5,  12, "Courier"; ;
  14.     fontset = message, inactive, noPageBreakBelow, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1,  12, "Courier"; ;
  15.     fontset = print, inactive, noPageBreakBelow, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1,  12, "Courier"; ;
  16.     fontset = info, inactive, noPageBreakBelow, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1,  12, "Courier"; ;
  17.     fontset = postscript, PostScript, formatAsPostScript, output, inactive, noPageBreakBelow, nowordwrap, preserveAspect, groupLikeGraphics, M7, l34, w282, h287, L1,  12, "Courier"; ;
  18.     fontset = name, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, italic, L1,  10, "Times"; ;
  19.     fontset = header, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1,  12;
  20.     fontset = Left Header, nohscroll, cellOutline,  12;
  21.     fontset = footer, inactive, nohscroll, noKeepOnOnePage, preserveAspect, center, M7, L1,  12;
  22.     fontset = Left Footer, cellOutline, blackBox,  12;
  23.     fontset = help, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1,  10, "Times"; ;
  24.     fontset = clipboard, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1,  12;
  25.     fontset = completions, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1,  12, "Courier"; ;
  26.     fontset = special1, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1,  12;
  27.     fontset = special2, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1,  12;
  28.     fontset = special3, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1,  12;
  29.     fontset = special4, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1,  12;
  30.     fontset = special5, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1,  12;]
  31. :[font = title; inactive; preserveAspect; startGroup; ]
  32. CantorSet.ma
  33. :[font = subsubtitle; inactive; preserveAspect; ]
  34. Steven R. Dunbar
  35. Department of Mathematics and Statistics
  36. University of Nebraska-Lincoln
  37. :[font = subsubtitle; inactive; preserveAspect; ]
  38. David Fowler
  39. Department of Curriculum and Instruction
  40. University of Nebraska-Lincoln
  41. :[font = smalltext; inactive; preserveAspect; right; ]
  42. ยช Copyright  Steven R. Dunbar, David Fowler, 1992, All rights reserved.  T
  43. ;[s]
  44. 2:0,0;1,1;74,-1;
  45. 2:1,0,0,Symbol,0,10,0,0,0;1,9,7,Times,0,10,0,0,0;
  46. :[font = section; inactive; preserveAspect; startGroup; ]
  47. Implementation
  48. :[font = subsection; inactive; preserveAspect; startGroup; ]
  49. set up the package context
  50. :[font = input; initialization; preserveAspect; startGroup; ]
  51. *)
  52. BeginPackage["CantorSet`"]
  53. (*
  54. :[font = output; output; inactive; preserveAspect; endGroup; endGroup; ]
  55. "CantorSet`"
  56. ;[o]
  57. CantorSet`
  58. :[font = subsection; inactive; autoActive; preserveAspect; startGroup; ]
  59. usage messages for the exported functions and the context itself
  60. :[font = input; initialization; preserveAspect; ]
  61. *)
  62. CantorSet::usage = "CantorSet is a collection of basic 
  63. routines for building and displaying approximations to 
  64. the Cantor set and its generalizations"
  65. (*
  66. :[font = input; initialization; preserveAspect; ]
  67. *)
  68. intervals::usage = "intervals[n] returns the list of 
  69. subintervals of {0,1} created by n iterations of the 
  70. middle third removal process." 
  71. (*
  72. :[font = input; initialization; wordwrap; preserveAspect; ]
  73. *)
  74. complementaryIntervals::usage = "complementaryIntervals[n] returns the list of subintervals removed in n iterations of the middle third removal process."
  75. (*
  76. :[font = input; initialization; preserveAspect; ]
  77. *)
  78. cantorSet::usage = "cantorSet[{a,b},r1,r2,n] returns
  79. a list of intervals created by the retaining a portion 
  80. r1 on the left of the interval {a,b}, a portion r2 on 
  81. the right, and removing the middle (1-r1-r2) portion."
  82. (*
  83. :[font = input; initialization; preserveAspect; ]
  84. *)
  85. complementaryCantorSet::usage = 
  86. "complementaryCantorSet[{a,b}, r1,r2,n] returns a list of
  87. of intervals removed by stage n in the process of creating
  88. cantorSet[{a,b},r1,r2,n]."
  89. (*
  90. :[font = input; initialization; preserveAspect; ]
  91. *)
  92. showIntervals::usage = "showIntervals[n] 
  93. gives a graphical representation of the first n stages 
  94. in the construction of the traditional Cantor set."  
  95. (*
  96. :[font = input; initialization; preserveAspect; ]
  97. *)
  98. showCantorSet::usage = "showCantorSet[{{a,b}}, r1, r2 ,n] 
  99. gives a graphical representation of the first n stages 
  100. in the construction of the generalized Cantor set."  
  101. (*
  102. :[font = input; initialization; preserveAspect; ]
  103. *)
  104. mapUnion::usage = "mapUnion[intervals_List, affinemaps_List]
  105. returns the list which is the union of the images of each of
  106. the affine maps from the argument affinemap applied to each 
  107. of the intervals in the argument intervals."
  108. (*
  109. :[font = input; initialization; wordwrap; preserveAspect; ]
  110. *)
  111. showMapUnion::usage = "showMapUnion[intervals_List,
  112. affinemaps_List, n] gives a graphical representation 
  113. of the first n stages of the iterated function system
  114. given by affinemaps applied to the intervals."
  115. (*
  116. :[font = input; initialization; wordwrap; preserveAspect; ]
  117. *)
  118. psi::usage = "psi[{a,b}, r1, r2, n] returns a Line graphics object which the stage n piecewise-linear approximation to the Cantor function on the genaralized Cantor set on interval {a,b} with preservation ratios r1,r2."
  119. (*
  120. :[font = input; initialization; wordwrap; preserveAspect; endGroup; ]
  121. *)
  122. cantorFunction::usage = "cantorFunction[n] returns a Line graphics object which the stage n piecewise-linear approximation to the classical Cantor function."
  123. (*
  124. :[font = subsection; inactive; preserveAspect; startGroup; ]
  125. set the private context
  126. :[font = input; initialization; preserveAspect; startGroup; ]
  127. *)
  128. Begin["`Private`"]
  129. (*
  130. :[font = output; output; inactive; preserveAspect; endGroup; endGroup; ]
  131. "CantorSet`Private`"
  132. ;[o]
  133. CantorSet`Private`
  134. :[font = subsection; inactive; preserveAspect; startGroup; ]
  135. definition of auxiliary functions
  136. :[font = text; inactive; preserveAspect; ]
  137. These  definitions are adapted from S. Wagon, Mathematica in Action, Section 4.2,  W. H. Freeman, 1991
  138. ;[s]
  139. 5:0,0;46,1;57,2;58,3;68,4;102,-1;
  140. 5:1,11,8,Times,0,12,0,0,0;1,10,8,Times,2,12,0,0,0;1,11,8,Times,0,12,0,0,0;1,10,8,Times,2,12,0,0,0;1,11,8,Times,0,12,0,0,0;
  141. :[font = input; initialization; autoActive; preserveAspect; startGroup; ]
  142. *)
  143. removePortions[{a_,b_}, r1_, r2_] := 
  144.     {{a,a+r1*(b-a)}, {b-r2*(b-a),b}} /; 
  145.         ((r1+r2<1) && NumberQ[N[a]] && NumberQ[N[b]])
  146. (*
  147. :[font = input; initialization; preserveAspect; endGroup; ]
  148. *)
  149. removePortions[intervals_List, r1_, r2_] :=
  150.     Flatten[Map[removePortions[# ,r1,r2] &, intervals],1]/;
  151.     Length[intervals[[1]]] > 1
  152. (*
  153. :[font = input; initialization; preserveAspect; endGroup; ]
  154. *)
  155. lines[n_Integer, l_List] :=
  156.     Map[Line[{{#[[1]], n+.5}, {#[[2]], n+.5}}] &,l];
  157. (*
  158. :[font = input; initialization; preserveAspect; ]
  159. *)
  160. showStages[stage_List] := 
  161. Module[ {level},
  162.     level = Length[stage]-1;
  163.     Show[
  164.         Graphics[
  165.             Map[lines[level--,#] &,
  166.                 stage
  167.              ]
  168.         ],
  169.     Axes->Automatic,
  170.     AxesOrigin->{0,0},
  171.     Ticks->{Automatic, None}
  172.     ]
  173. ]
  174. (*
  175. :[font = input; initialization; preserveAspect; ]
  176. *)
  177. psinodes[interval_, r1_, r2_, n_] := 
  178. Module[ {ci = complementaryCantorSet[interval, r1,r2,n]},
  179.     nodepts = Flatten[{interval[[1]],ci,interval[[2]]}];
  180.     heights = Flatten[{0,
  181.                          Table[{j*2^(-n), j*2^(-n)}, 
  182.                          {j, Length[ci]}
  183.                        ],
  184.                        1
  185.                       }
  186.                 ];
  187.     Transpose[ {nodepts, heights}]
  188. ]
  189. (*
  190. :[font = subsection; inactive; preserveAspect; startGroup; ]
  191. definition of the exported functions
  192. :[font = input; initialization; preserveAspect; startGroup; ]
  193. *)
  194. cantorSet[interval_, r1_, r2_, n_] := 
  195.     cantorSet[interval, r1, r2, n] =
  196.        removePortions[cantorSet[interval,r1,r2,n-1], r1, r2]
  197.     
  198. (*
  199. :[font = input; initialization; preserveAspect; ]
  200. *)
  201. cantorSet[interval_,r1_,r2_,1] = 
  202.         removePortions[interval,r1,r2];
  203. (*
  204. :[font = input; initialization; preserveAspect; ]
  205. *)
  206. complementaryCantorSet[interval_, r1_, r2_, n_] :=
  207. Partition[ Drop[Rest[Flatten[
  208. cantorSet[interval, r1,r2,n]]],-1],2]
  209. (*
  210. :[font = input; initialization; preserveAspect; ]
  211. *)
  212. intervals[n_] := cantorSet[{0,1}, 1/3,1/3,n]
  213. (*
  214. :[font = input; initialization; preserveAspect; endGroup; ]
  215. *)
  216. complementaryIntervals[n_] :=
  217.  Partition[ Drop[Rest[Flatten[intervals[n]]], -1],2]
  218. (*
  219. :[font = input; initialization; preserveAspect; ]
  220. *)
  221. showCantorSet[intervals_List, r1_, r2_, n_] := 
  222. showStages[
  223.     NestList[
  224.         removePortions[#, r1,r2] &,
  225.         intervals, n]]
  226. (*
  227. :[font = input; initialization; preserveAspect; endGroup; ]
  228. *)
  229. showIntervals[n_] := showCantorSet[{{0,1}}, 1/3, 1/3,n]        
  230. (*
  231. :[font = input; initialization; preserveAspect; ]
  232. *)
  233. mapUnion[interval_List, affinemap_List] :=
  234. Apply[
  235.     Union,
  236.     Table[ 
  237.         Map[
  238.             affinemap[[i,1]] + #*affinemap[[i,2]] &, 
  239.             interval,
  240.             {2}],
  241.         {i,Length[affinemap]}]]
  242. (*
  243. :[font = input; initialization; preserveAspect; ]
  244. *)
  245. showMapUnion[interval_List, affinemap_List, n_] :=
  246.     showStages[
  247.         NestList[
  248.             mapUnion[#, affinemap] &,
  249.             interval,
  250.             n
  251.         ]
  252.     ]
  253. (*
  254. :[font = input; initialization; preserveAspect; ]
  255. *)
  256. psi[interval_, r1_, r2_, n_] := 
  257.     Line[psinodes[interval, r1, r2, n]]
  258. (*
  259. :[font = input; initialization; preserveAspect; ]
  260. *)
  261. cantorFunction[n_] := psi[{0,1}, 1/3,1/3, n]
  262. (*
  263. :[font = subsection; inactive; preserveAspect; startGroup; ]
  264. epilog
  265. :[font = input; initialization; preserveAspect; ]
  266. *)
  267. End[]    (* end the private context *)
  268. (*
  269. :[font = input; initialization; wordwrap; preserveAspect; ]
  270. *)
  271. Protect[intervals, complementaryIntervals, showCantorSet, showIntervals, mapUnion, showMapUnion, psi, cantorFunction]
  272. (*
  273. :[font = input; initialization; preserveAspect; endGroup; endGroup; endGroup; ]
  274. *)
  275. EndPackage[]     (* end the package context *)
  276. (*
  277. ^*)